00100	C  *****  NSCTPY  JUL 16 71 ******  WRITES ON MAGTAPE OR DSK.  NO SCOPE!
00200	C  ****** LOAD WITH TAPOUT.REL  *********
00300	C   TO WRITE ON DSK: BIGBIT←1; OR RCDFLG←1;    TO WRITE ON TAPE: BIGBIT←-1;
00400	C  BIGBIT←>1; WRITES ON DSK, 4TH LETTER OF NAME IS SET BY NUMBER.
00500	C   IF RCDFLG IS NOT 0 OR 1, ONE LONG FILE IS WRITTEN. PLAY WITH 'PLAY'.
00600		SUBROUTINE SMPLS(LSBUF,ISBCNT,IBOTT,MAXAMP,BIGBIT,RCDFLG)
00700		COMMON JSB(10)
00800		DIMENSION MX(3),INM(3),MZ(4),IBOTT(1),MQ(5)
00900		EQUIVALENCE (JSB(3),JSB3),(JSB(4),JSB4),(JSB(5),JSB5)
01000		DATA (MX(JSC),JSC=1,2)/'AMPL.=0 /'/,INM(2)/' AMP='/
01100		DATA (MZ(K),K=1,3)/'ADJUST LSBUF!**'/
01200		DATA JSAVE/33000/
01300		IF(J)GO TO 6
01400	86	K=-1
01500	   	IEND=-1
01600		LNM=0
01700		NUM=0
01800		IMAX=50000
01900		IF(BIGBIT.EQ.0)GO TO 8
02000		IF(RCDFLG.GT.8000)JSAVE=RCDFLG
02100		RCDFLG=0
02200	C   WILL SAVE AFTER C.33K UNLESS RCDFLG>8K
02300	87	IF(BIGBIT.LT.0)GO TO 88
02400		IF(BIGBIT.LT.1)GO TO 8
02500		JSC=BIGBIT-1.
02600		LNM='MUSAA'+256*JSC
02700		BIGBIT=.5
02800	C  NAME CHANGE ONLY WORKS WHEN WRITING ON DSK.
02900		J=0
03000		GO TO 87
03100	88	K=0
03200	CC	CALL MESS(MZ)
03300		KBIT=2
03400		GO TO 9
03500	8	KBIT=3.-BIGBIT
03600		IF(RCDFLG.GT.1.)RCDFLG=-1.
03700	9	IF(RCDFLG.NE.-1)IBOTT(1024)=0
03800		JSB(2)=KBIT
03900	C   KBIT=3, 12-BITS.  KBIT=2, 18-BITS. JSB(2) PASSES KBIT TO CONVRT.
04000		IF(J.EQ.1)GO TO 5
04100		JNM='MUSAA'
04200		IF(LNM.NE.0)JNM=LNM
04300	1	INM(1)=JNM
04400		KNM=JNM
04500		J=1
04600	5	IF(INM(1).LE.JNM+50)GO TO 2
04700		JNM=JNM+256
04800		IF(JNM.LE.KNM+6400)GO TO 3
04900		KNM=JNM+26112
05000		JNM=KNM
05100	C   RAISES 'AAAZA' TO 'AABAA'
05200	3	INM(1)=JNM
05300	C   NAMES GO FROM 'AAAAA' TO 'AAZZZ': MUSAA,MUSAB,MUSAC,ETC.
05400	2	IF(K)GO TO 33
05500		CALL GETTAP
05600		GO TO 34
05700	33	CALL PUTFIL(INM(1))
05800	34	J=-1
05900		JSC=LSBUF
06000	C  IF RCDFLG←-1; LSBUF=1024 -- OTHERWISE LSBUF=1023 AND LAST WD(1024) IS AMP.
06100		IF(RCDFLG)GO TO 666
06200		JSC=LSBUF+1
06300	C  WRITES LSBUF+1 WDS.  THE '+1' WILL HAVE MAXAMP IN LAST BUFFER.
06400		JSB(1)=JSC
06500		JSB3=INM(1)
06600		JSB4=9999
06700		JSB5=9998
06800		IF(K)GO TO 66
06900		CALL TOTAPE(JSB(1),128)
07000		GO TO 6
07100	C666	JSC=1024
07200	666	IMAX=2050
07300		GO TO 6
07400	66	CALL FASTOU(JSB(1),128)
07500	6	IF(ISBCNT.NE.0)GO TO 7
07600		IF(NUM+LSBUF.LT.JSAVE.OR.RCDFLG)GO TO 4
07700	10	IBOTT(JSC)=MAXAMP
07800		IF(MAXAMP.EQ.0)IBOTT(JSC)=1
07900	C  IF 0, THEN NO WAY TO FIND END OF FILE IN OTHER PROGS.
08000	5444	IEND=0
08100		GO TO 4
08200	7	IF(RCDFLG)GO TO 5444
08300		IBOTT(LSBUF)=(ISBCNT-1)/KBIT       
08400		MAXAMP=-MAXAMP
08500	C  LAST WRD OF LSBUF IS USED FOR WDCNT OF FREE SPACE IN LAST BUFFER.
08600	C  -MAXAMP TELLS CONVRT IT'S THE LAST BUFFER.
08700		GO TO 10
08800	4	NUM=NUM+LSBUF
08900		IF(MAXAMP.EQ.0)CALL MESS(MX)
09000	CC	GO TO 4444
09100		IF(MAXAMP.LT.IMAX)GO TO 4444
09200	C  IABS(MAXAMP) WON'T WORK 1ST TIME AROUND!!!!!!!⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗
09300	C   49999 IS MAXIMUM AMPL. POSSIBLE (ARBITRARY NUMBER.)
09400		CALL MESS(INM)
09500		CALL MESS(INM)
09600		CALL MESS(INM)
09700		CALL MESS(INM)
09800		CALL PNUM(MAXAMP)
09900	        GO TO 227
10000	4444	IF(K)GO TO 44
10100		 CALL TOTAPE(IBOTT(1),JSC)
10200		GO TO 45
10300	44	CALL FASTOU(IBOTT(1),JSC)
10400	45	IF(IEND)RETURN
10500		IF(RCDFLG)GO TO 224
10600	22	JSB(1)=-1
10700		JSB3=INM(1)
10800		JSB4=9999
10900		JSB5=9998
11000		IF(K)GO TO 222
11100		CALL TOTAPE(JSB(1),128)
11200	C    '-1' MARKS END OF THIS BATCH OF DATA.
11300	C    '9999' IDENTIFIES IT AS MUSIC DATA WHEN TAPE IS READ.
11400		CALL FINTAP
11500		CALL BACKSP
11600		CALL BACKSP
11700		GO TO 223
11800	224	K=NUM/LSBUF
11900		J=0
12000		NUM=4-K-(K/4*4)
12100	C  MAKES MULTIPLES OF 4K.
12200		J=0
12300	CC	IF(NUM.EQ.0)GO TO 2221
12400	2251	DO 225 K=1,1024
12500	225	IBOTT(K)=0
12600	2261	DO 226 K=1,NUM
12700	226	CALL FASTOU(IBOTT(1),LSBUF)
12800	227	CALL FINFIL
12900		GO TO 2221
13000	222	CALL FASTOU(JSB(1),128)
13100		CALL FINFIL
13200	223	J=1
13300	2231	IF(RCDFLG.GE.0)CALL SAVER
13400		JSB(1)=0
13500	2221	CALL MESS(INM)
13600		CALL PNUM(MAXAMP)
13700		INM(1)=INM(1)+2
13800		RETURN
13900		END
14000	
14100	
14200	C  ********** SEG  --  *********
14300	
14400		SUBROUTINE SEG(FUNC)
14500	C  TYPE AMPL, STEP# (UP TO STEP 512). ---- SAME FORMAT AS GEN 1 IN MUSIC5.
14600		DIMENSION FUNC(512),A(4)
14700		COMMON K,STEP,AMP1,AMP2,DIF,IT,IS,ST,STPS,RK
14800		DATA (A(K),K=1,3)/'SEG ARRAY FULL/'/
14900		AMP1=0
15000		ST=0
15100	1	CALL RDNUM(AMP2)
15200		CALL RDNUM(STEP)
15300		IF(STEP.GT.1.)GO TO 3
15400		AMP1=AMP2
15500		GO TO 1
15600	C  STEP=1 AND STEP=0 ARE CONSIDERED THE SAME.
15700	3	DIF=AMP2-AMP1
15800	5	IT=ST
15900		IS=STEP*5.120+.0001
16000		STEP=IS
16100	 	STPS=STEP-ST
16200		IS=STPS
16300		IF(IS+IT.GT.512)GO TO 6
16400		ST=STEP
16500		IF(ST.EQ.0)STEP=1.
16600		DO 2 K=1,IS
16700	CC	M=K+IT
16800		RK=K
16900	2	FUNC(K+IT)=AMP1+DIF*RK/STPS
17000		AMP1=AMP2
17100	      	ST=STEP
17200	CC	CALL PNUM(M)
17300		IF(STEP.LT.512)GO TO 1
17400	CC	IF(STEP.GT.513.)GO TO 6
17500	1102	CALL MESS(A)
17600	CC*** WHY WAS THIS HERE????	FUNC(1)=0.0
17700		RETURN
17800	6	K=1
17900	8	CALL RDNUM(RK)
18000	7	FUNC(K)=RK
18100		K=K+1
18200		IF(K.LE.512)GO TO 8
18300		GO TO 1102
18400		END
18500	
18600		SUBROUTINE SYNTH (FUNC)
18700	C  AFTER 'SYNTH(F1);'  TYPE 99= TO USE  H,A,P,K: ALL OTHER
18800	C   NUMBERS = H,A ONLY.  TYPE 999 TO END. NORMALIZATION IS AUTOMATIC.
18900		DIMENSION FUNC(512),F(5)
19000		COMMON I,XX,X,H,K,CON,XK,FAC,AMP,Y
19100		DATA (F(I),I=1,4)/'SYNTH ARRAY FULL/'/
19200		DO 15 I=1,512
19300	15	FUNC(I)=0.0
19400	 	CALL RDNUM(XX)
19500		IF(XX.EQ.99)XX=-99
19600		FAC=360./512.
19700		H=XX
19800		IF(XX)CALL RDNUM(H)
19900	16	CALL RDNUM(AMP)
20000		IF(XX)GO TO 1016
20100		X=0
20200		CON=0
20300		GO TO 2016
20400	1016	CALL RDNUM(X)
20500		X=X*512./360.+1.0
20600		CALL RDNUM(CON)
20700	2016	DO 17 J=1,512
20800		XK=SIND(X*FAC)*AMP+CON
20900		IF(CON.LT.100.0)GO TO 1
21000		FUNC(J)=(XK-100.)*FUNC(J)
21100		GO TO 2
21200	1	FUNC(J)=FUNC(J)+XK
21300	2	X=X+H
21400		IF(X.LE.512.)GO TO 17
21500		X=X-512.
21600	17	CONTINUE
21700		CALL RDNUM(H)
21800		IF(H.NE.999.)GO TO 16
21900	2200	X=FUNC(1)
22000		DO 19 I=2,512
22100		H=ABS(FUNC(I))
22200	19	IF(X.LT.H)X=H
22300		DO 20 I=1,512
22400	20	FUNC(I)=FUNC(I)/X
22500		CALL MESS(F)
22600		RETURN
22700		END
22800	C   ***********  DUR2 1969  *********
22900		FUNCTION DUR(P2,SPEED,CHNS)
23000		COMMON P,ISR,NC,IDUR,ID,IP(5)
23100		DATA IP/20000,25000,10000,50000,100000/
23200		P=P2
23300		ISPD=SPEED
23400		NC=CHNS*30+.3
23500	3	IDUR=P*10000+.5
23600	5	IDUR=(IDUR*IP(ISPD))/1000
23700	6	ID=IDUR/NC
23800	7	ID=IDUR-ID*NC
23900		IF(ID.EQ.0)GO TO 1
24000		P=P+.0001
24100		GO TO 3
24200	1	DUR=P
24300		RETURN
24400		END
24500	
24600	
24700		SUBROUTINE SEE(FUNC)
24800	
24900		DIMENSION FUNC(512),SU(150),C(3)
25000	 	DATA (C(I),I=1,2)/'0=CLEAR: '/
25100	CC	CALL DDCLR
25200	C  THIS VERSION MUST BE LOADED WITH %LTVRLIB (FOR 'DDCLR')
25300	CC	CALL TYPLOC(-300,-512)
25400		CALL DPYSET(2,SU,150)
25500	CC	CALL DPYBRT(6)
25600		CALL ALINE(-264,0,256,0)
25700		CALL ALINE(-256,-256,-256,256)
25800		CALL AIVECT(0,0)
25900	1	IY=FUNC(1)*256.0
26000		CALL AIVECT(-256,IY)
26100		DO 14 I=2,512,3
26200		IY2=FUNC(I)*256.0
26300		CALL RVECT(3,IY2-IY)
26400	14	IY=IY2
26500		CALL DPYOUT(2)
26600	100	CALL MESS(C)
26700	1100   	CALL RDNUM(X)
26800		CALL DPYCLR
26900		RETURN
27000		END
27100	
27200		FUNCTION POWER(X,Y)
27300		POWER=EXP(Y*ALOG(X))
27400		RETURN
27500		END